home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 3: CDPD 3 / Almathera Ten on Ten - Disc 3: CDPD3.iso / fish / 001-100 / 001-025 / 018 / xlisp1.6 / xleval.c < prev    next >
C/C++ Source or Header  |  1995-03-17  |  8KB  |  364 lines
  1. /* xleval - xlisp evaluator */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern int xlsample;
  10. extern NODE ***xlstack,***xlstkbase,*xlenv;
  11. extern NODE *s_lambda,*s_macro;
  12. extern NODE *k_optional,*k_rest,*k_aux;
  13. extern NODE *s_evalhook,*s_applyhook;
  14. extern NODE *s_unbound;
  15. extern NODE *s_stdout;
  16.  
  17. /* trace variables */
  18. extern NODE **trace_stack;
  19. extern int xltrace;
  20.  
  21. /* forward declarations */
  22. FORWARD NODE *xlxeval();
  23. FORWARD NODE *evalhook();
  24. FORWARD NODE *evform();
  25. FORWARD NODE *evfun();
  26.  
  27. /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
  28. NODE *xleval(expr)
  29.   NODE *expr;
  30. {
  31.     /* check for control codes */
  32.     if (--xlsample <= 0) {
  33.     xlsample = SAMPLE;
  34.     oscheck();
  35.     }
  36.  
  37.     /* check for *evalhook* */
  38.     if (getvalue(s_evalhook))
  39.     return (evalhook(expr));
  40.  
  41.     /* add trace entry */
  42.     if (++xltrace < TDEPTH)
  43.     trace_stack[xltrace] = expr;
  44.  
  45.     /* check type of value */
  46.     if (consp(expr))
  47.     expr = evform(expr);
  48.     else if (symbolp(expr))
  49.     expr = xlgetvalue(expr);
  50.  
  51.     /* remove trace entry */
  52.     --xltrace;
  53.  
  54.     /* return the value */
  55.     return (expr);
  56. }
  57.  
  58. /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
  59. NODE *xlxeval(expr)
  60.   NODE *expr;
  61. {
  62.     /* check type of value */
  63.     if (consp(expr))
  64.     expr = evform(expr);
  65.     else if (symbolp(expr))
  66.     expr = xlgetvalue(expr);
  67.  
  68.     /* return the value */
  69.     return (expr);
  70. }
  71.  
  72. /* xlapply - apply a function to a list of arguments */
  73. NODE *xlapply(fun,args)
  74.   NODE *fun,*args;
  75. {
  76.     NODE *env,*val;
  77.  
  78.     /* check for a null function */
  79.     if (fun == NIL)
  80.     xlfail("bad function");
  81.  
  82.     /* evaluate the function */
  83.     if (subrp(fun))
  84.     val = (*getsubr(fun))(args);
  85.     else if (consp(fun)) {
  86.     if (consp(car(fun))) {
  87.         env = cdr(fun);
  88.         fun = car(fun);
  89.     }
  90.     else
  91.         env = xlenv;
  92.     if (car(fun) != s_lambda)
  93.         xlfail("bad function type");
  94.     val = evfun(fun,args,env);
  95.     }
  96.     else
  97.     xlfail("bad function");
  98.  
  99.     /* return the result value */
  100.     return (val);
  101. }
  102.  
  103. /* evform - evaluate a form */
  104. LOCAL NODE *evform(expr)
  105.   NODE *expr;
  106. {
  107.     NODE ***oldstk,*fun,*args,*env,*val,*type;
  108.  
  109.     /* create a stack frame */
  110.     oldstk = xlsave(&fun,&args,NULL);
  111.  
  112.     /* get the function and the argument list */
  113.     fun = car(expr);
  114.     args = cdr(expr);
  115.  
  116.     /* evaluate the first expression */
  117.     if ((fun = xleval(fun)) == NIL)
  118.     xlfail("bad function");
  119.  
  120.     /* evaluate the function */
  121.     if (subrp(fun) || fsubrp(fun)) {
  122.     if (subrp(fun))
  123.         args = xlevlist(args);
  124.     val = (*getsubr(fun))(args);
  125.     }
  126.     else if (consp(fun)) {
  127.     if (consp(car(fun))) {
  128.         env = cdr(fun);
  129.         fun = car(fun);
  130.     }
  131.     else
  132.         env = xlenv;
  133.     if ((type = car(fun)) == s_lambda) {
  134.         args = xlevlist(args);
  135.         val = evfun(fun,args,env);
  136.     }
  137.     else if (type == s_macro) {
  138.         args = evfun(fun,args,env);
  139.         val = xleval(args);
  140.     }
  141.     else
  142.         xlfail("bad function type");
  143.     }
  144.     else if (objectp(fun))
  145.     val = xlsend(fun,args);
  146.     else
  147.     xlfail("bad function");
  148.  
  149.     /* restore the previous stack frame */
  150.     xlstack = oldstk;
  151.  
  152.     /* return the result value */
  153.     return (val);
  154. }
  155.  
  156. /* evalhook - call the evalhook function */
  157. LOCAL NODE *evalhook(expr)
  158.   NODE *expr;
  159. {
  160.     NODE ***oldstk,*ehook,*ahook,*args,*val;
  161.  
  162.     /* create a new stack frame */
  163.     oldstk = xlsave(&ehook,&ahook,&args,NULL);
  164.  
  165.     /* make an argument list */
  166.     args = consa(expr);
  167.     rplacd(args,consa(xlenv));
  168.  
  169.     /* rebind the hook functions to nil */
  170.     ehook = getvalue(s_evalhook);
  171.     setvalue(s_evalhook,NIL);
  172.     ahook = getvalue(s_applyhook);
  173.     setvalue(s_applyhook,NIL);
  174.  
  175.     /* call the hook function */
  176.     val = xlapply(ehook,args);
  177.  
  178.     /* unbind the symbols */
  179.     setvalue(s_evalhook,ehook);
  180.     setvalue(s_applyhook,ahook);
  181.  
  182.     /* restore the previous stack frame */
  183.     xlstack = oldstk;
  184.  
  185.     /* return the value */
  186.     return (val);
  187. }
  188.  
  189. /* xlevlist - evaluate a list of arguments */
  190. NODE *xlevlist(args)
  191.   NODE *args;
  192. {
  193.     NODE ***oldstk,*src,*dst,*new,*val;
  194.     NODE *last = NIL;
  195.  
  196.     /* create a stack frame */
  197.     oldstk = xlsave(&src,&dst,NULL);
  198.  
  199.     /* initialize */
  200.     src = args;
  201.  
  202.     /* evaluate each argument */
  203.     for (val = NIL; src; src = cdr(src)) {
  204.  
  205.     /* check this entry */
  206.     if (!consp(src))
  207.         xlfail("bad argument list");
  208.  
  209.     /* allocate a new list entry */
  210.     new = consa(NIL);
  211.     if (val)
  212.         rplacd(last,new);
  213.     else
  214.         val = dst = new;
  215.     rplaca(new,xleval(car(src)));
  216.     last = new;
  217.     }
  218.  
  219.     /* restore the previous stack frame */
  220.     xlstack = oldstk;
  221.  
  222.     /* return the new list */
  223.     return (val);
  224. }
  225.  
  226. /* xlunbound - signal an unbound variable error */
  227. xlunbound(sym)
  228.   NODE *sym;
  229. {
  230.     xlcerror("try evaluating symbol again","unbound variable",sym);
  231. }
  232.  
  233. /* evfun - evaluate a function */
  234. LOCAL NODE *evfun(fun,args,env)
  235.   NODE *fun,*args,*env;
  236. {
  237.     NODE ***oldstk,*oldenv,*newenv,*cptr,*fargs,*val;
  238.  
  239.     /* create a stack frame */
  240.     oldstk = xlsave(&oldenv,&newenv,&cptr,NULL);
  241.  
  242.     /* skip the function type */
  243.     if ((fun = cdr(fun)) == NIL || !consp(fun))
  244.     xlfail("bad function definition");
  245.  
  246.     /* get the formal argument list */
  247.     if ((fargs = car(fun)) && !consp(fargs))
  248.     xlfail("bad formal argument list");
  249.  
  250.     /* create a new environment frame */
  251.     newenv = xlframe(env);
  252.     oldenv = xlenv;
  253.  
  254.     /* bind the formal parameters */
  255.     xlabind(fargs,args,newenv);
  256.     xlenv = newenv;
  257.  
  258.     /* execute the code */
  259.     for (cptr = cdr(fun); cptr; )
  260.     val = xlevarg(&cptr);
  261.  
  262.     /* restore the environment */
  263.     xlenv = oldenv;
  264.  
  265.     /* restore the previous stack frame */
  266.     xlstack = oldstk;
  267.  
  268.     /* return the result value */
  269.     return (val);
  270. }
  271.  
  272. /* xlabind - bind the arguments for a function */
  273. xlabind(fargs,aargs,env)
  274.   NODE *fargs,*aargs,*env;
  275. {
  276.     NODE *arg;
  277.  
  278.     /* evaluate and bind each required argument */
  279.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  280.  
  281.     /* bind the formal variable to the argument value */
  282.     xlbind(arg,car(aargs),env);
  283.  
  284.     /* move the argument list pointers ahead */
  285.     fargs = cdr(fargs);
  286.     aargs = cdr(aargs);
  287.     }
  288.  
  289.     /* check for the '&optional' keyword */
  290.     if (consp(fargs) && car(fargs) == k_optional) {
  291.     fargs = cdr(fargs);
  292.  
  293.     /* bind the arguments that were supplied */
  294.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  295.  
  296.         /* bind the formal variable to the argument value */
  297.         xlbind(arg,car(aargs),env);
  298.  
  299.         /* move the argument list pointers ahead */
  300.         fargs = cdr(fargs);
  301.         aargs = cdr(aargs);
  302.     }
  303.  
  304.     /* bind the rest to nil */
  305.     while (consp(fargs) && !iskeyword(arg = car(fargs))) {
  306.  
  307.         /* bind the formal variable to nil */
  308.         xlbind(arg,NIL,env);
  309.  
  310.         /* move the argument list pointer ahead */
  311.         fargs = cdr(fargs);
  312.     }
  313.     }
  314.  
  315.     /* check for the '&rest' keyword */
  316.     if (consp(fargs) && car(fargs) == k_rest) {
  317.     fargs = cdr(fargs);
  318.     if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
  319.         xlbind(arg,aargs,env);
  320.     else
  321.         xlfail("symbol missing after &rest");
  322.     fargs = cdr(fargs);
  323.     aargs = NIL;
  324.     }
  325.  
  326.     /* check for the '&aux' keyword */
  327.     if (consp(fargs) && car(fargs) == k_aux)
  328.     while ((fargs = cdr(fargs)) != NIL && consp(fargs))
  329.         xlbind(car(fargs),NIL,env);
  330.  
  331.     /* make sure the correct number of arguments were supplied */
  332.     if (fargs != aargs)
  333.     xlfail(fargs ? "too few arguments" : "too many arguments");
  334. }
  335.  
  336. /* iskeyword - check to see if a symbol is a keyword */
  337. LOCAL int iskeyword(sym)
  338.   NODE *sym;
  339. {
  340.     return (sym == k_optional || sym == k_rest || sym == k_aux);
  341. }
  342.  
  343. /* xlsave - save nodes on the stack */
  344. NODE ***xlsave(n)
  345.   NODE **n;
  346. {
  347.     NODE ***oldstk,***nptr;
  348.  
  349.     /* save the old stack pointer */
  350.     oldstk = xlstack;
  351.  
  352.     /* save each node pointer */
  353.     for (nptr = &n; *nptr; nptr++) {
  354.     if (xlstack <= xlstkbase)
  355.         xlabort("evaluation stack overflow");
  356.     *--xlstack = *nptr;
  357.     **nptr = NIL;
  358.     }
  359.  
  360.     /* return the old stack pointer */
  361.     return (oldstk);
  362. }
  363.  
  364.